home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swaga_c.zip / COLOR.SWG / 0014_Palette Control #3.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  11KB  |  406 lines
  1. Unit Palette;
  2.  
  3. Interface
  4.  
  5. Type
  6.   PalType     =  Array [0..768] of Byte;
  7. Var
  8.   FadePal     :  Array [0..768] of Real;
  9.   Fadeend,
  10.   FadeStep,
  11.   FadeCount,
  12.   FadeStart   :  Byte;
  13.   FadeToPal   :  ^PalType;
  14.   DoneFade    :  Boolean;
  15.  
  16. Procedure GetPCXPalettePas (PCXBuf,P:Pointer;PalOffset:Word);
  17. Procedure GetPCXPaletteAsm (PCXBuf,P:Pointer;PalOffset:Word);
  18.  
  19. Procedure WritePalettePas  (Start,Finish:Byte;P:Pointer);
  20. Procedure WritePaletteAsm  (Start,Finish:Byte;P:Pointer);
  21.  
  22. Procedure ReadPalettePas   (Start,Finish:Byte;P:Pointer);
  23. Procedure ReadPaletteAsm   (Start,Finish:Byte;P:Pointer);
  24.  
  25. Procedure SetupFade        (Start,Finish:Byte;P:Pointer;Step:Byte);
  26. Procedure FadePalette;
  27. Procedure Oreo             (Start,Finish:Integer);
  28.  
  29. Implementation
  30.  
  31. Procedure CLI; Inline ($FA);
  32. Procedure STI; Inline ($FB);
  33.  
  34. Procedure SetupFade (Start,Finish:Byte;P:Pointer;Step:Byte);
  35. Var
  36.   CurPal           :  Array [0..767] of Byte;
  37.   ToPal            :  ^PalType;
  38.   I,PalOfs,
  39.   NumColors        :  Word;
  40.   RealStep,
  41.   RealToColor,
  42.   RealCurColor     :  Real;
  43. begin
  44.   ToPal := Ptr (Seg(P^),Ofs(P^));
  45.   ReadPaletteAsm (0,255,@CurPal);
  46.   PalOfs := Start * 3;
  47.   NumColors := (Finish - Start + 1) * 3;
  48.  
  49.   RealStep := Step;
  50.  
  51.   For I := 0 to NumColors-1 do begin
  52.     RealCurColor := CurPal [PalOfs+I];
  53.     RealToColor  :=  ToPal^[PalOfs+I];
  54.     FadePal [PalOfs+I] := (RealCurColor - RealToColor) / RealStep;
  55.     end;
  56.  
  57.   FadeStep  := 0;
  58.   FadeCount := Step;
  59.   FadeStart := Start;
  60.   Fadeend   := Finish;
  61.   FadeToPal := P;
  62.   DoneFade  := False;
  63. end;
  64.  
  65. Procedure FadePalette;
  66. Var
  67.   I,
  68.   PalOfs,
  69.   NumColors   :  Word;
  70.   CurPal      :  Array [0..767] of Byte;
  71.   Fact,
  72.   RealToColor :  Real;
  73. begin
  74.   Inc (FadeStep);
  75.   Fact := FadeCount - FadeStep;
  76.   NumColors := (Fadeend - FadeStart + 1) * 3;
  77.   ReadPaletteAsm (0,255,@CurPal);
  78.   PalOfs := FadeStart * 3;
  79.  
  80.   For I := 0 to NumColors - 1 do begin
  81.     RealToColor := FadeToPal^[PalOfs+I];
  82.     CurPal[PalOfs+I] := Round (RealToColor + Fact * FadePal[PalOfs+I]);
  83.     end;
  84.  
  85.   WritePaletteAsm (FadeStart,Fadeend,@CurPal);
  86.   DoneFade := FadeStep = FadeCount;
  87. end;
  88.  
  89. Procedure Oreo (Start,Finish:Integer);
  90. Var
  91.   I,PalOfs    :  Word;
  92.   CurPal      :  Array [0..767] of Byte;
  93.   Red,
  94.   Blue,
  95.   Green       :  Real;
  96.   Gray        :  Byte;
  97. begin
  98.   ReadPaletteAsm (0,255,@CurPal);
  99.  
  100.   For I := Start to Finish do begin
  101.     PalOfs := I * 3;
  102.     Red   := CurPal[PalOfs + 0];
  103.     Green := CurPal[PalOfs + 1];
  104.     Blue  := CurPal[PalOfs + 2];
  105.  
  106.     Gray := Round ((0.30 * Red) + (0.59 * Green) + (0.11 * Blue));
  107.  
  108.     CurPal[PalOfs + 0] := Gray;
  109.     CurPal[PalOfs + 1] := Gray;
  110.     CurPal[PalOfs + 2] := Gray;
  111.     end;
  112.   WritePaletteAsm (Start,Finish,@CurPal);
  113. end;
  114.  
  115. Procedure GetPCXPalettePas (PCXBuf,P:Pointer;PalOffset:Word);
  116. Var
  117.   I      :  Word;
  118.   InByte :  Byte;
  119. begin
  120.   PCXBuf := Ptr (Seg(PCXBuf^),Ofs(PCXBuf^)+PalOffset);
  121.   For I := 0 to 767 do begin
  122.     InByte := Mem [Seg(PCXBuf^):Ofs(PCXBuf^)+I];
  123.     InByte := InByte shr 2;
  124.     Mem [Seg(P^):Ofs(P^)+I] := InByte;
  125.     end;
  126. end;
  127.  
  128. Procedure WritePalettePas (Start,Finish:Byte;P:Pointer);
  129. Var
  130.   I,
  131.   NumColors   :  Word;
  132.   InByte      :  Byte;
  133. begin
  134.   P := Ptr (Seg(P^),Ofs(P^)+Start*3);
  135.   NumColors := (Finish - Start + 1) * 3;
  136.  
  137.   CLI;
  138.  
  139.   Port [$03C8] := Start;
  140.  
  141.   For I := 0 to NumColors do begin
  142.     InByte := Mem [Seg(P^):Ofs(P^)+I];
  143.     Port [$03C9] := InByte;
  144.     end;
  145.  
  146.   STI;
  147. end;
  148.  
  149. Procedure ReadPalettePas (Start,Finish:Byte;P:Pointer);
  150. Var
  151.   I,
  152.   NumColors   :  Word;
  153.   InByte      :  Byte;
  154. begin
  155.   P := Ptr (Seg(P^),Ofs(P^)+Start*3);
  156.   NumColors := (Finish - Start + 1) * 3;
  157.  
  158.   CLI;
  159.  
  160.   Port [$03C7] := Start;
  161.  
  162.   For I := 0 to NumColors do begin
  163.     InByte := Port [$03C9];
  164.     Mem [Seg(P^):Ofs(P^)+I] := InByte;
  165.     end;
  166.  
  167.   STI;
  168. end;
  169.  
  170. Procedure GetPCXPaletteAsm (PCXBuf,P:Pointer;PalOffset:Word);
  171. Assembler;
  172. Asm
  173.     push ds
  174.  
  175.     lds  si,PCXBuf
  176.     mov  ax,PalOffset
  177.     add  si,ax
  178.  
  179.     les  di,P
  180.  
  181.     mov  cx,768
  182.   @@1:
  183.     lodsb
  184.     shr  al,1
  185.     shr  al,1
  186.     stosb
  187.     loop @@1
  188.  
  189.     pop  ds
  190. end;
  191.  
  192. Procedure WritePaletteAsm (Start,Finish:Byte;P:Pointer); Assembler;
  193. Asm
  194.     push ds
  195.  
  196.     lds  si,P
  197.  
  198.     cld
  199.  
  200.     xor  bh,bh               { P^ points to the beginning of the palette }
  201.     mov  bl,Start            { data.  Since we can specify the Start and }
  202.     xor  ax,ax               { Finish color nums, we have to point our }
  203.     mov  al,Start            { Pointer to the Start color.  There are 3 }
  204.     shl  ax,1                { Bytes per color, so the Start color is: }
  205.     add  ax,bx               {   Palette Ofs = @P + Start * 3 }
  206.     add  si,ax               { ds:si -> offset in color data }
  207.  
  208.     xor  ch,ch               { Next, we have to determine how many colors}
  209.     mov  cl,Finish           { we will be updating.  This simply is: }
  210.     sub  cl,Start            {    NumColors = Finish - Start + 1 }
  211.     inc  cx
  212.  
  213. (*
  214.     push      es
  215.     push      dx
  216.     push      ax
  217.  
  218.     xor       ax,ax                    { get address of status register }
  219.     mov       es,ax                    {   from segment 0 }
  220.     mov       dx,3BAh                  { assume monochrome addressing }
  221.     test      Byte ptr es:[487h],2     { is mono display attached? }
  222.     jnz       @@11                     { yes, address is OK }
  223.     mov       dx,3DAh                  { no, must set color addressing }
  224.   @@11:
  225.     in        al,dx                    { read in status }
  226.     jmp       @@21
  227.   @@21:
  228.     test      al,08h                   { is retrace on> (if ON, bit = 1) }
  229.     jz        @@13                     { no, go wait For start }
  230.   @@12:
  231.                                        { yes, wait For it to go off }
  232.     in        al,dx
  233.     jmp       @@22
  234.   @@22:
  235.     test      al,08h                   { is retrace off? }
  236.     jnz       @@12                     { no, keep waiting }
  237.   @@13:
  238.     in        al,dx
  239.     jmp       @@23
  240.   @@23:
  241.     test      al,08h                   { is retrace on? }
  242.     jz        @@13                     { no, keep on waiting }
  243.  
  244.     pop       ax
  245.     pop       dx
  246.     pop       es               *)
  247.  
  248.     mov  al,Start            { We are going to bypass the BIOS routines }
  249.     mov  dx,03C8h            { to update the palette Registers.  For the }
  250.     out  dx,al               { smoothest fades, there is no substitute }
  251.  
  252.     cli                      { turn off interrupts temporarily }
  253.     inc  dx
  254.  
  255.   @@1:
  256.     lodsb                    { Get the red color Byte }
  257.     jmp  @@2                 { Delay For a few clock cycles }
  258.   @@2:
  259.     out  dx,al               { Write the red register directly }
  260.  
  261.     lodsb                    { Get the green color Byte }
  262.     jmp  @@3                 { Delay For a few clock cycles }
  263.   @@3:
  264.     out  dx,al               { Write the green register directly }
  265.  
  266.     lodsb                    { Get the blue color Byte }
  267.     jmp  @@4                 { Delay For a few clock cycles }
  268.   @@4:
  269.     out  dx,al               { Write the blue register directly }
  270.  
  271.     loop @@1
  272.  
  273.     sti                      { turn interrupts back on }
  274.     pop  ds
  275. end;
  276.  
  277. Procedure ReadPaletteAsm (Start,Finish:Byte;P:Pointer); Assembler;
  278. Asm
  279.     les  di,P
  280.  
  281.     cld
  282.  
  283.     xor  bh,bh               { P^ points to the beginning of the palette }
  284.     mov  bl,Start            { buffer.  We have to calculate where in the}
  285.     xor  ax,ax               { buffer we need to start at.  Because each  }
  286.     mov  al,Start            { color has three Bytes associated With it }
  287.     shl  ax,1                { the starting ofs is:            }
  288.     add  ax,bx               {   Palette Ofs = @P + Start * 3  }
  289.     add  si,ax               { es:di -> offset in color data   }
  290.  
  291.     xor  ch,ch               { Next, we have to determine how many   colors}
  292.     mov  cl,Finish           { we will be reading.  This simply is:  }
  293.     sub  cl,Start            {    NumColors = Finish - Start + 1     }
  294.     inc  cx
  295.  
  296.     mov  al,Start            { We are going to bypass the BIOS routines }
  297.     mov  dx,03C7h            { to read in from the palette Registers.   }
  298.     out  dx,al               { This is the fastest method to do this.   }
  299.     mov  dx,03C9h
  300.  
  301.     cli                      { turn off interrupts temporarily          }
  302.  
  303.   @@1:
  304.     in   al,dx               { Read in the red color Byte               }
  305.     jmp  @@2                 { Delay For a few clock cycles             }
  306.   @@2:
  307.     stosb                    { Store the Byte in the buffer             }
  308.  
  309.     in   al,dx               { Read in the green color Byte             }
  310.     jmp  @@3                 { Delay For a few clock cycles             }
  311.   @@3:
  312.     stosb                    { Store the Byte in the buffer             }
  313.  
  314.     in   al,dx               { Read in the blue color Byte              }
  315.     jmp  @@4                 { Delay For a few clock cycles             }
  316.   @@4:
  317.     stosb                    { Store the Byte in the buffer             }
  318.     loop @@1
  319.  
  320.     sti                      { turn interrupts back on                  }
  321. end;
  322.  
  323. end.
  324. {
  325.  
  326. **********************************************
  327. Here's the testing Program
  328. **********************************************
  329. }
  330. Program MCGATest;
  331.  
  332. Uses
  333.   Crt,Dos,MCGALib,Palette;
  334.  
  335. Var
  336.   Stop,
  337.   Start       :  LongInt;
  338.   Regs        :  Registers;
  339.   PicBuf,
  340.   StorageBuf  :  Pointer;
  341.   FileLength  :  Word;
  342.   Pal,
  343.   BlackPal    :  Array [1..768] of Byte;
  344.  
  345. Const
  346.   NumTimes    = 100;
  347.  
  348. Procedure LoadBuffer (S:String;Buf:Pointer);
  349. Var
  350.   F           :  File;
  351.   BlocksRead  :  Word;
  352. begin
  353.   Assign (F,S);
  354.   Reset (F,1);
  355.   BlockRead (F,Buf^,65000,FileLength);
  356.   Close (F);
  357. end;
  358.  
  359. Procedure Pause;
  360. Var
  361.   Ch     :  Char;
  362. begin
  363.   Repeat Until KeyPressed;
  364.   While KeyPressed do Ch := ReadKey;
  365. end;
  366.  
  367. Procedure Control;
  368. begin
  369.   SetGraphMode ($13);
  370.  
  371.   LoadBuffer ('E:\NAVAJO.PCX',PicBuf);
  372.  
  373.   GetPCXPaletteAsm (PicBuf,@Pal,FileLength-768);
  374.   WritePalettePas (0,255,@Pal);
  375.   DisplayPCX (0,0,PicBuf);
  376.  
  377.   FillChar (BlackPal,SizeOf(BlackPal),0);
  378.   Pause;
  379.  
  380.   SetupFade (0,255,@BlackPal,20);
  381.   Repeat FadePalette Until DoneFade;
  382.   Pause;
  383.  
  384.   SetupFade (0,255,@Pal,20);
  385.   Repeat FadePalette Until DoneFade;
  386.   Pause;
  387.  
  388.   Oreo (0,255);
  389.   Pause;
  390.  
  391.   SetupFade (0,255,@Pal,20);
  392.   Repeat FadePalette Until DoneFade;
  393.   Pause;
  394. end;
  395.  
  396. Procedure Init;
  397. begin
  398.   GetMem (PicBuf,65500);
  399. end;
  400.  
  401. begin
  402.   Init;
  403.   Control;
  404. end.
  405.  
  406.